perm filename COMPIL.VLI[VLI,LSP] blob
sn#381966 filedate 1978-09-08 generic text, type C, neo UTF8
COMMENT ā VALID 00049 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 C O M P I L . V L I
C00008 00003 3 initialisations.
C00015 00004 4 indicateurs globaux et COMPILOPTIONS
C00018 00005 5 MACMP : macros du compilateur
C00021 00006 6 types 1ere passe : *SSB *SSBP *SSB1
C00025 00007 7 predicats : *TYPFNT *UNIQUEP *18BITP
C00027 00008 8 chargement : -lskip -larithi -laritha *ISKIP
C00029 00009 9 chargement : *ADD *ADD1
C00031 00010 10 *ADD1 : suite
C00034 00011 11 *ADD1 : suite
C00037 00012 12 *ADD1 : suite
C00040 00013 13 *ADD1 : suite
C00043 00014 14 labels et registres : *RSTL *RESOL *SCR *RCR
C00046 00015 15 recherches : *OPT
C00048 00016 16 Recherche des S-exprs communes : *LKM *LK0 *LK1
C00050 00017 17 table des litteraux #TBL : *PKST *LKT *LKSTBL
C00052 00018 18 otres recherches : -lkst *KST *PKST *LKT *ISARG
C00053 00019 19 generation predicat : *CMPREDSTD *CMPRED
C00056 00020 20 *CMPRED : (suite)
C00059 00021 21 *CMPRED : (suite)
C00061 00022 22 gener. speciale : *NIEWIEM *PA1 *LAMBDA *PROGN *TWO
C00063 00023 23 : gener. speciale : *TWO
C00065 00024 24 : DGEN
C00067 00025 25 : fnts DGENs :
C00068 00026 26 *GEN0SUBR *GEN1SUBR
C00071 00027 27 *GEN2SUBR
C00073 00028 28 *GEN : QUOTE 0SUBR 1SUBR 1SUBRS 2SUBR
C00076 00029 29 *GEN : 1SUBARITH 2SUBRARITH
C00078 00030 30 *GEN : 3SUBR
C00081 00031 31 *GEN : NSUBR NSUBR1 NSUBR2 STATUS FSUBR
C00083 00032 32 *GEN : CONS SELF C...R OR
C00085 00033 33 *GEN : ARRAY SETQA
C00087 00034 34 *GEN : IF PROGN DE
C00090 00035 35 *GEN : COND
C00092 00036 36 *GEN : SELECTQ
C00095 00037 37 *GEN : ESCAPE LESCAPE WHILE
C00098 00038 38 *GEN : REPEAT NEXTL SETQ SETQQ
C00101 00039 39 *GEN : FUNCTION LAMBDA MAPC
C00103 00040 40 fonction de compilation : *CMP
C00107 00041 41 impressions : *LENS *LENL PRCOMMENT PRMAC
C00109 00042 42 impressions : PRTBL PRCOD
C00111 00043 43 impressions : PRLAP SORTL
C00113 00044 44 fnts principales : COMPIL
C00116 00045 45 fnts principales : COMPILPR
C00118 00046 46 fnts stds : COMPILES COMPILE COMPILERROR COMPILEREASE
C00121 00047 47 fnts stds : COMPILEFILE
C00124 00048 48 fnts stds : COMPILEFILE (suite) COMPILEF
C00126 00049 49 fnts stds : COMPILEND COMPILINDIC
C00131 ENDMK
Cā;
; C O M P I L . V L I ;
; ;
; Compilateur / Accelerateur VLISP 10 . 3 ;
;----------------------------------------------------------;
; Jerome CHAILLOUX ;
; ;
; Universite de Paris VIII - Vincennes ;
; Route de la Tourelle 75012 Paris ;
; Tel : 374 12 50 poste 299 ;
; ;
; I.R.C.A.M. ;
; 31 Rue St Merri 75004 Paris ;
; Tel : 277 12 33 poste 48-48 ;
;----------------------------------------------------------;
; ;
; regles de reconnaissance des identificateurs : ;
; ;
; 1er car. signification ;
; ;
; & fonctions d'echappements (ESCAPEs) ;
; * fonctions du compilateur ;
; - variables globales a tout le compilateur ;
; # variables libres pour certaines fonctions ;
; (mais liees par des fnts du compilateur) ;
; ! indicateurs sur P-listes ;
; ? indicateurs du compilateur (e.g. T ou NIL) ;
; : symboles connus du LOD/LAP ;
; (ces symboles ont ete charges par LINK 10) ;
;----------------------------------------------------------;
;;
; pour eviter tout malentendu ... ;
(MAPC '(& * - # ! ? : @ + %) (LAMBDA (X) (STATUS 19 X)))
;;
;;
(POUR PRETTY (PUT '*ADD 'PROGN 'PRETTY))
; 3 initialisations. ;
;;
; pour lancer commodement le compilateur ;
(STATUS 18 '/ā '(LAMBDA () (COMPILES (READ))))
;;
; intialisation du compteur de fonctions gensymees ;
(OR (BOUNDP 'CPTFNT) (SETQ CPTFNT 0))
;;
; initialisation des indicateurs des fonctions connues : ;
; le 1er est le selecteur de la fonction *GEN ;
; le 2eme est utilise pour *OPT (type std de l'appel) ;
; le 3eme est utilise pour la 1ere passe ;
; le 4eme = T si la fonction peut se compiler ;
; open dans n'inporte quel registre ;
(PROGN
;;
; init de toutes les SUBRs / FSUBRs non open ;
; en recuperant le F-TYP de tous les atomes systemes ;
;;
(SETQ :MEM4 (+ (STATUS 42 1) 4))
(MAPC (OBLIST)
(LAMBDA (L)
(OR (LE (LOC L) (LOC 'STOP)) (LESCAPE))
(SELECTQ (TYPEFN L)
(FSUBR (PUT L '(FSUBR) '!cmp))
(SUBR
(PUT L
(SELECTQ
(1-
(LOGSHIFT (STATUS 41 (+ :MEM4 (LOC L))) -18))
(0 '(0SUBR 0SUBR 0SUBR))
(1 '(1SUBR 1SUBR 1SUBR))
(2 '(2SUBR 2SUBR 2SUBR))
(3 '(3SUBR 3SUBR 3SUBR))
('(NSUBR NSUBR NSUBR)))
'!cmp))
(NIL))))
;-----;
; init SUBRs speciales non open ;
;-----;
(MAPC '(:$PRINT :$PRIN1 :$PUSH)
(LAMBDA (L) (PUT L '(1SUBR 1SUBR 1SUBR) '!cmp)))
(MAPC '(:$PLUS :$TIMES)
(LAMBDA (L) (PUT L '(2SUBR 2SUBR 2SUBR) '!cmp)))
(MAPC '(TERPRI POP)
(LAMBDA (L) (PUT L '(1SUBRS 1SUBR 1SUBR) '!cmp)))
(MAPC '(ADD1 SUB1 ABS COMPL SWAP MINUS)
(LAMBDA (L) (PUT L '(1SUBRARITH 1SUBR 1SUBR) '!cmp)))
(MAPC '(LOGAND LOGOR LOGXOR :$PLUS :$DIFFER
:$TIMES :$QUO)
(LAMBDA (L) (PUT L '(2SUBRARITH 2SUBR 2SUBR) '!cmp)))
(MAPC '(PRINT PRIN1 PRINC)
(LAMBDA (L) (PUT L '(NSUBRS1 NSUBR NSUBR) '!cmp)))
(MAPC '(PLUS DIFFER TIMES QUO REM MIN MAX GT GE LT LE)
(LAMBDA (L) (PUT L '(NSUBRS2 NSUBR NSUBR) '!cmp)))
(PUT 'LIST '[NSUBR NSUBR] '!cmp)
(PUT 'STATUS '(STATUS NSUBR NSUBR) '!cmp)
(PUT 'SETQA '(SETQA 3SUBR 3SUBR) '!cmp)
(MAPC '(MAPC MAP)
(LAMBDA (L) (PUT L '(MAPC 2SUBR NSUBR) '!cmp)))
(MAPC '(ESCAPE LESCAPE SELF) (LAMBDA (L)
(PUT L [L 'FSUBR L] '!cmp)))
;;
; init des fonctions de definition ;
;;
(MAPC '(DE DF DM DMI DMO)
'(LAMBDA (L) (PUT L '(DE FSUBR) '!cmp)))
;---;
; initialisation des fonctions OPEN ;
;---;
;;
; selecteurs ;
(MAPC
'(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR
CDDAR CDDDR CAAAAR CAAADR CAADAR CAADDR CADAAR CADDAR CADADR CADDDR
CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR)
'(LAMBDA (L) (PUT L '(CAR 1SUBR 1SUBR T) '!cmp)))
;;
; controle open ;
(MAPC '(OR AND)
'(LAMBDA (L) (PUT L '(OR NSUBR NSUBR T) '!cmp)))
(MAPC '(UNTIL WHILE)
'(LAMBDA (L) (PUT L '(WHILE NSUBR NSUBR T) '!cmp)))
(MAPC '(IF IFN) '(LAMBDA (L) (PUT L '(IF NSUBR IF T) '!cmp)))
(MAPC
'(NEXTL PROGN SETQ SETQQ COND REPEAT LAMBDA SELECTQ)
'(LAMBDA (L) (PUT L [L 'NSUBR L T] '!cmp)))
(MAPC '(INCR DECR)
'(LAMBDA (L) (PUT L '(INCR FSUBR INCR) '!cmp)))
(MAPC '(NEWL) '(LAMBDA (L) (PUT L [L 'FSUBR L] '!cmp)))
(MAPC '(FUNCTION QUOTE)
'(LAMBDA (L) (PUT L [L '1SUBR L] '!cmp)))
;;
; autres ;
(MAPC '(RPLACA RPLACD)
(LAMBDA (L) (PUT L '(2SUBR 2SUBR 2SUBR T) '!cmp)))
(PUT 'CONS '(CONS 2SUBR 2SUBR T) '!cmp)
;-----;
; fonctions commutatives a 2 arguments ;
;-----;
(MAPC
'(EQP NEQP EQ NEQ EQUAL NEQUAL :$PLUS :$TIMES :$MIN :$MAX
+ * LOGAND LOGOR LOGXOR)
'(LAMBDA (L) (PUT L L '!commut)))
(MAPC
'((CONS . XCONS) (XCONS . CONS) (:$GT . :$LE) (:$GE . :$LT)
(:$LT . :$GE) (:$LE . :$GT))
'(LAMBDA (L) (PUT (CAR L) (CDR L) '!commut)))
)))))
; certains indicateurs !cmp sont poses par la fonction COMPILOPTIONS ;
; 4 indicateurs globaux et COMPILOPTIONS ;
(DE COMPILOPTIONS L
; lecture des options du compilateur ;
; on positionne les derniers indicateurs ;
; si L=NIL, initialisation par (READ). ;
(IF L
(SETQ ?nohacks (NEXTL L)
?nossec (NEXTL L)
?slonum (NEXTL L)
?open (NEXTL L)
?ckarray (NEXTL L)
?filap (NEXTL L))
(PRINT '?nohacks ?nohacks) (SETQ ?nohacks (READ))
(PRINT '?nossec ?nossec) (SETQ ?nossec (READ))
(PRINT '?slonum ?slonum) (SETQ ?slonum (READ))
(PRINT '?open ?open) (SETQ ?open (READ))
(PRINT '?ckarray ?ckarray) (SETQ ?ckarray (READ))
(PRINT '?filap ?filap) (SETQ ?filap (READ)))
(MAPC '(;TYI; :$POP :$PSTACK)
(LAMBDA (L) (PUT L
(IF ?open '(0SUBR 0SUBR 0SUBR T)
'(0SUBR 0SUBR 0SUBR)) '!cmp)))
(MAPC '(ATOM DIM ID ;LENGTH; LITATOM LISTP
NOT NULL NCONS NUMBP TYO :$PUSH)
(LAMBDA (L) (PUT L
(IF ?open '(1SUBR 1SUBR 1SUBR T)
'(1SUBR 1SUBR 1SUBR)) '!cmp)))
(MAPC '(EQP :$GE :$GT :$LE :$LT :$MAX :$MIN NEQP RPLACB XCONS)
(LAMBDA (L) (PUT L
(IF ?open '(2SUBR 2SUBR 2SUBR T)
'(2SUBR 2SUBR 2SUBR)) '!cmp)))
(PUT 'CONS (IF ?open '(CONS 2SUBR 2SUBR T)
'(CONS 2SUBR 2SUBR))
'!cmp)
'COMPILOPTIONS)
; initialisation des indicateurs globaux ;
(COMPILOPTIONS
NIL ; ?nohacks : utilise pour tester le compilo. ;
T ; ?nossec : pour ne pas calculer les sous-exprs communes ;
NIL ; ?slonum : on utilise les nombres lents ;
T ; ?open : on macrogenere au maximum ;
NIL ; ?ckarray : on controle les indices des tableaux ;
NIL ; ?filap : on cre une file .LAP (sinon .VLA) ;
)
; 5 MACMP : macros du compilateur ;
; utilisees e.g. pour casser les NSUBRs ;
(DF MACMP (L)
; definition d'une macro ;
(PUT (CAR L) (CONS LAMBDA (CDR L)) '!macmp)))))
(DF TMACMP (L)
; teste d'une expansion de macro du compilo ;
(APPLY (GET (CAR L) '!macmp) [L])))
(DE MEXPAND (L F)
; expansion std d'une macro ;
(COND
((NULL L) NIL)
((NULL (CDR L)) (CAR L))
(T [F (CAR L) (MEXPAND (CDR L) F)]))))
(DE MEXPAND2 (L F1 F2)
; expansion speciale a 2 fonctions ;
(COND
((NULL L) NIL)
((NULL (CDR L)) [F2 (CAR L)])
(T [F1 (CAR L) (MEXPAND2 (CDR L) F1 F2)])))
(DE MEXPARITH (L F)
; expansion arith de type (F (F ... (F x x) ... x) x) ;
(COND
((NULL L) NIL)
((NULL (CDR L)) (CAR L))
(T [F (MEXPARITH (CDR L) F) (CAR L)])))
; macros proprement dites ;
(MACMP APPEND1 (L)
['APPEND (CADR L) (CONS 'LIST (CDDR L))]))
(MACMP DECR (L)
['SETQ (CADR L) ['SUB1 (CADR L)]]))
(MACMP DIFFER (L)
(MEXPARITH (REVERSE (CDR L)) ':$DIFFER))
(MACMP INCR (L)
['SETQ (CADR L) ['ADD1 (CADR L)]]))
(MACMP LIST (L)
(MEXPAND2 (CDR L) 'CONS 'NCONS))
(MACMP MCONS (L)
(MEXPAND (CDR L) 'CONS))
(MACMP NCONC1 (L)
['NCONC (CADR L) (CONS 'LIST (CDDR L))]))
(MACMP NEWL (L)
['SETQ (CADR L) ['CONS (CADDR L) (CADR L)]]))
(MACMP PLUS (L)
(MEXPARITH (REVERSE (CDR L)) ':$PLUS))
(MACMP PRINT (L)
(SETQ L (CONS 'PROGN (MAPCAR (CDR L)
(LAMBDA (L) [':$PRIN1 L]))))
(RPLACA (CAR (LAST L)) ':$PRINT)
L)
(MACMP PRIN1 (L)
(CONS 'PROGN (MAPCAR (CDR L)
(LAMBDA (L) [':$PRIN1 L]))))
(MACMP PUSH (L)
(CONS 'PROGN (MAPCAR (CDR L)
(LAMBDA (L) [':$PUSH L]))))
(MACMP QUO (L)
(MEXPARITH (REVERSE (CDR L)) ':$QUO))
(MACMP TIMES (L)
(MEXPARITH (REVERSE (CDR L)) ':$TIMES))))
; 6 types 1ere passe : *SSB *SSBP *SSB1 ;
(DE *SSB (L ;; A D X)
; recherche si la fonction L est une 1SUBR, ;
; tres tres prudemment (even paranoid people have enemies) ;
; A = l'argument de la fonction, ;
; D = T s'il n'est plus dans A1, ;
; ramene T ou NIL ;
(IF (NEQ (LENGTH (CADDR L)) 1) (LESCAPE))
(IF (CDR (CADDR L)) (LESCAPE))
(PUT (CADR L) '(1SUBR 1SUBR 1SUBR) '!cmp)
; on met l'indic pour les fnts recursives ;
(SETQ L (CDDR L) A (CAAR L))
(ESCAPE &exit (MAPC (CDR L) '*SSB1) T))
(DE *SSBP (L)
; idem a *SSB1 mais L est en position predicat ;
(COND
((ATOM L) (IF (NEQ A L) (SETQ D T) (IF D (&exit))))
((NUMBP (CAR L)) (**SSBP (CONS 'CNTH L)))
((SETQ X (OR (GET (CAR L) 'MACRO)
(GET (CAR L) '!macmp)))
(*SSBP (APPLY X [L])))
((MEMQ (CAR L)
'(ATOM LITATOM LISTP NEROP NOT NUMBP NULL ZEROP))
(*SSB1 (CADR L)))
((AND (MEMQ (CAR L) '(EQ NEQ MEMQ)) (*KST (CADDR L)))
(*SSB1 (CADR L)))
(T (*SSB1 L))))
(DE *SSB1 (L)
; regarde si on touche a A1 dans L ;
(COND
((ATOM L) (IF (NEQ A L) (SETQ D T) (IF D (&exit))))
((NUMBP (CAR L)) (*SSB1 (CONS 'NTH L)))
((SETQ X (OR (GET (CAR L) 'MACRO)
(GET (CAR L) '!macmp)))
(*SSB1 (APPLY X [L])))
((SETQ X (CADDR (GET (NEXTL L) '!cmp)))
(SELECTQ X
(0SUBR NIL)
(LAMBDA
(IF (AND (LISTP (CAR L)) (MEMQ A (CAR L)))
()
(&exit)))
((FUNCTION QUOTE)
(IF
(AND
(LISTP (CAR L))
(EQ (CAAR L) LAMBDA)
(LISTP (CADAR L))
(MEMQ A (CADAR L))) NIL (&exit)))
(1SUBR (*SSB1 (CAR L)))
(2SUBR (*SSB1 (CAR L)) (*SSB1 (CADR L)))
(3SUBR
(*SSB1 (CAR L))
(*SSB1 (CADR L))
(*SSB1 (CADDR L)))
(NSUBR
(MAPC L
(FUNCTION (LAMBDA (L) (OR (*KST L) (*SSB1 L))))))
(IF
(*SSBP (CAR L))
(PUSH D)
(*SSB1 (CADR L))
(SETQ D (POP))
(MAPC (CDDR L) '*SSB1))
(COND
(MAPC L
'(LAMBDA (L)
(IF (NULL (CDR L))
(*SSB1 (CAR L))
(IF (NEQ (CAR L) T) (*SSBP (NEXTL L)))
(PUSH D)
(MAPC L '*SSB1)
(SETQ D (POP))))))
(NEWL (*SSB1 (CADR L)))
((&exit)))
(SETQ D T))
(T (&exit))))
; 7 predicats : *TYPFNT *UNIQUEP *18BITP ;
(DE *TYPFNT (L)
; ramene le type de la fonction L : ;
; 0SUBR 1SUBR 2SUBR 3SUBR NSUBR FSUBR ;
(PUT (CADR L) (CADDR L) '!larg)
(SELECTQ (CAR L)
(DE
(PUT (CADR L)
(IF (*SSB L)
'(1SUBR 1SUBR 1SUBR)
(IF (AND (CADDR L) (OR (ATOM (CADDR L))
(CDR (LAST (CADDR L)))) )
'(NSUBR NSUBR)
(SELECTQ (LENGTH (CADDR L))
(0 '(0SUBR 0SUBR))
(1 '(1SUBR 1SUBR))
(2 '(2SUBR 2SUBR))
(3 '(3SUBR 3SUBR))
('(NSUBR NSUBR)))))
'!cmp)
(CADR (GET (CADR L) '!cmp)))
(DF
(IF (CADDR L)
; ya des args ;
(PROGN (PUT (CADR L) '(FSUBR FSUBR) '!cmp) 'FSUBR)
; ya pas d'arg donc == 0SUBR ;
(PUT (CDAR L) '(0SUBR 0SUBR) '!cmp) '0SUBR))
(NIL)))
(DE *UNIQUEP (L)
; predicat qui teste si L a une representation unique ;
(OR (LITATOM L) (INUMBP L)))
(DE *18BITP (N)
; teste si le nb N est une constante sur 18 bits (1/2 mot) ;
(LE \-777777 N \777777)))
; 8 chargement : -lskip -larithi -laritha *ISKIP ;
; initialisation de la liste des SKIPs ;
(SETQ
-lskip
'((TDZA . TDZA) (SKIPA . SKIPA) (SKIPN . SKIPE) (SKIPE . SKIPN)
(SKIPL . SKIPGE) (SKIPLE . SKIPG) (SKIPG . SKIPLE)
(SKIPGE . SKIPL) (CAIN . CAIE) (CAIE . CAIN)
(CAIL . CAIGE)(CAILE . CAIG)(CAIG . CAILE)(CAIGE . CAIL)
(CAMLE . CAMG) (CAMG . CAMLE) (CAME . CAMN) (CAMN . CAME)
(CAML . CAMGE) (CAMGE . CAML)))
; initialisation des listes des instructions arithmetiques ;
(SETQ -larithi
'((:$PLUS . ADDI) (:$DIFFER . SUBI) (:$TIMES . IMULI)
(:$QUO . IDIVI) (LOGAND . ANDI) (LOGOR . IORI)
(LOGXOR . XORI)))
(SETQ -laritha
'((:$PLUS . ADD) (:$DIFFER . SUB) (:$TIMES . IMUL)
(:$QUO . IDIV) (LOGAND . AND) (LOGOR . IOR) (LOGXOR . XOR)))
(DE *ISKIP (L)
; teste si a partir de L ya un skip ;
(COND
((NULL L) NIL)
((ATOM (CAR L)) (*ISKIP (CDR L)))
((ASSQ (CAAR L) -lskip))
(T NIL)))
; 9 chargement : *ADD *ADD1 ;
(DE *ADD L ; rajoute du code a la liste #lap ; (MAPC L '*ADD1))
(DE *ADD1 (L ;; X)
;;
; rajoute 1 instruction a #lap ;
; de + traite les petits HACKs ;
;;
; pour les tests du compilo ;
;;
(AND ?nohacks (LESCAPE (SETQ #lap (CONS L #lap) #ca1 NIL)))
;;
(SETQ X (CAR #lap))
(COND
((LITATOM X)
; 1) on a stocke une etiquette juste avant ;
; construit la table des equivalences #label ;
(COND
((LITATOM L)
; ... LAB1 LAB2 ... ;
(SETQ #label (CONS (CONS X L) #label)))
((EQ (CAR L) 'JRST)
; ... LAB1 (JRST 0 XXX) ... ;
(SETQ #label (CONS (CONS X (CADDR L)) #label)))
((EQ (CAR L) 'POPJ)
; ... LAB1 (POPJ P) ... ;
(SETQ #label (CONS (CONS X L) #label)))))
;;
; attention la fonction *ADD1 continue ..... ;
; 10 *ADD1 : suite ;
;;
((LITATOM L)
; 2) on veut stocker une etiquette ;
(COND
((AND (EQ (CADDR X) L) (NOT (*ISKIP (CDR #lap))))
; JUMP QUELCONQUE JUSTE EN DESSOUS ;
; ... (JUMPX 0 LAB) LAB ... ;
(SETQ #lap (CDR #lap)))
((AND
(MEMQ (CAR X) '(JRST POPJ))
(EQ (CADDR (CADR #lap)) L))
(COND
((AND
(MEMQ (CAADR #lap) '(JUMPE JUMPN))
(NOT (*ISKIP (CDDR #lap))))
; ... (JUMPx 0 LAB) (POPJ P) LAB ... ;
; ... (JUMPx 0 LAB) (JRST 0 Lxxx) LAB ... ;
(SETQ #lap (CDR #lap))
(RPLACA (CAR #lap)
(IF (EQ (CAAR #lap) 'JUMPE)
'JUMPN
'JUMPE))
(RPLACA (CDDAR #lap)
(IF (EQ (CAR X) 'JRST) (CADDR X) ':VPOPJ)))
((AND
(EQ (CAADR #lap) 'JRST)
(*ISKIP (CDDR #lap))
(NEQ (CADDR #lap) 'SKIPA)
(NOT (*ISKIP (CDDDR #lap))))
; ... (SKIP xx) (JRST LAB) (JRST xxx) LAB ... ;
; ... (SKIP xx) (JRST LAB) (POPJ P) LAB ... ;
(SETQ
X
['JRST
0
(IF (EQ (CAR X) 'JRST)
(CADDR X)
':VPOPJ)])
(SETQ #lap (CDDR #lap))
(RPLACA
(IF (LISTP (CAR #lap))
(CAR #lap)
(CADR #lap))
(CASSQ (CAAR #lap) -lskip))
(SETQ #lap (CONS X #lap)))))))
;;
; attention la fonction *ADD1 continue ..... ;
; 11 *ADD1 : suite ;
;;
((LISTP L)
; 3) on veut stocker une liste ;
(COND
((EQ (CAR L) 'POPJ)
; 3.1 ) on met un 'POPJ' ;
; il faut creer de nouvelles listes : ['jrst .. ] ;
; a cause des RPLACAs dans *ADD1 ! ;
(OR
(*ISKIP (CDR #lap))
(COND
((EQ (CAR X) 'PUSHJ)
; THE FAMOUS JRST HACK ;
; ... (PUSHJ P XXX) (POPJ P) ... ;
(SETQ L ['JRST 0 (CADDR X)])
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 L)))
((EQ (CAR X) 'JRST)
; ENLEVE LES POPJs EN TROP ;
; ... (JRST xxx) (POPJ P) ... ;
(LESCAPE))
((EQUAL X '(JSP L :NSUBR))
; ... (JSP L :NSUBR) (POPJ P) ... ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 '(JRST 0 :NSUBRP))))
((EQUAL X '(MOVEI 1 '0))
; ... (MOVEI 1 '0) (POPJ P) ... ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 ['JRST 0 ':CRAZER])))
((EQUAL X '(MOVEI 1 '1))
; ... (MOVEI 1 '1) (POPJ P) ... ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 ['JRST 0 ':CRAONE])))
((EQUAL X '(SETZ 1))
; ... (SETZ 1) (POPJ P) ... ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 ['JRST 0 ':FALSE])))
((EQUAL X '(MOVEI 1 'T))
; ... (MOVEI 1 T) (POPJ P) ... ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 ['JRST 0 ':TRUTH])))
((EQUAL X '(JSP L :$CRANB))
; ... (JSP L :$CRANB) (POPJ P) ... ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 ['JRST 0 ':CRANUM])))
((OR
(EQ (CAR X) 'POPJ)
(EQ (CADDR X) ':VPOPJ))
; ... (JUMPX R :VPOPJ) (POPJ P) ... ;
(SETQ #lap (CDR #lap))))))
;;
; ATTENTION : la fonction *ADD1 continue ..... ;
; 12 *ADD1 : suite ;
;;
((EQ (CAR L) 'JRST)
; ENLEVE LES JRSTS DEVENUS INUTILES ;
(AND
(MEMQ (CAR X) '(JRST POPJ))
(NOT (*ISKIP (CDR #lap)))
(LESCAPE)))
((AND (EQ (CAR L) 'SUB) (EQ (CAR X) 'SUB)
(EQ (CADR L) 'P) (EQ (CADR L) 'P))
; ... (SUB P [n n]) (SUB P [m m]) ... ;
(SETQ X (PLUS (CAR (*LKSTBL (CADDR L)))
(CAR (*LKSTBL (CADDR X)))))
(SETQ L ['SUB 'P (*LKT ['XWD X X])])
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 L)))
((EQUAL X '(JSP L :$CRANB))
; on vient d'interner le nb dans A5 ;
(COND
((EQUAL L '(PUSH P 1))
; ... (JSP L :$CRANB) (PUSH P 1) ... ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 '(JSP L :$CRANP))))
((EQUAL L '(MOVE 5 :MEM 1))
; ... (JSP L :$CRANB) (MOVE 5 :MEM 1) ... ;
; L'internement est donc inutile ;
(LESCAPE (SETQ #lap (CDR #lap))))
((AND (EQ (CADDR L) ':MEM) (EQ (CADDDR L) 1))
; ... (JSP L :$CRANB) (xxx x :MEM 1) ... ;
; la valeur est toujours dans A5 ;
; l'internement n'est donc pas necessaire ;
(SETQ #lap (CDR #lap))
(LESCAPE (*ADD1 [(CAR L) (CADR L) 5])))))
((EQUAL L '(MOVE 5 :MEM 1))
; on veut prendre la valeur numerique de A1 ;
(IF (AND (EQUAL (CADR #lap) '(JSP L :$CRANB))
(NEQ (CADR X) 1) (NEQ (CADDR X) 1)
(NEQ (CADDDR X) 1)
(NULL (ASSQ (CAR X) -LSKIP)))
; on peut donc eviter de l'interner precedemnt ;
(PROGN (SETQ #lap (CDDR #lap))
(SETQ L X))))
;;
; attention la fonction *ADD1 continue ..... ;
; 13 *ADD1 : suite ;
;;
((AND (EQ (CAR L) 'HRL)
(EQ (CADR X) (CADDR L)))
; amelioration du CONS ;
(COND
((MEMQ (CAR X) '(MOVEI SETZ GETVAL CAR CDR))
; ... (SETZ R) (HRL yyy R) ... ;
; ... (GETVAL R xxx) (HRL yyy R) ... ;
; ... (CAR/CDR/MOVEI R z) (HRL yyy R) ... ;
(SETQ #lap (CDR #lap))
(IF (EQ (CADR X) 1) ; il est pu ds R ; (SETQ #ca1))
(LESCAPE (*ADD1
(SELECTQ (CAR X)
(GETVAL ['HLL (CADR L) [':MEM [QUOTE (CADDR X)]]])
(CAR (MCONS 'HLL (CADR L) ':MEM (CDDR X)))
(CDR (MCONS 'HRL (CADR L) ':MEM (CDDR X)))
(MOVEI (MCONS 'HRLI (CADR L) (CDDR X)))
(SETZ ['HLLI (CADR L)])
(NIL)))))
(T NIL)))
((AND (EQ (CAR L) 'HRLZ)
(EQ (CADR X) (CADDR L)))
; amelioration du NCONS (cf: amelioration du CONS ;
(COND
((MEMQ (CAR X) '(MOVEI SETZ GETVAL CAR CDR))
; ... (SETZ R) (HRZL yyy R) ... ;
; ... (GETVAL R xxx) (HRLZ yyy R) ... ;
; ... (CAR/CDR/MOVEI R zzz) (HRLZ yyy R) ... ;
(SETQ #lap (CDR #lap))
(IF (EQ (CADR X) 1) ; il est pu ds R ; (SETQ #ca1))
(LESCAPE (*ADD1
(SELECTQ (CAR X)
(GETVAL ['HLLZ (CADR L) [':MEM [QUOTE (CADDR X)]]])
(CAR (MCONS 'HLLZ (CADR L) ':MEM (CDDR X)))
(CDR (MCONS 'HRLZ (CADR L) ':MEM (CDDR X)))
(MOVEI (MCONS 'HRLZI (CADR L) (CDDR X)))
(SETZ ['SETZ (CADR L)])
(NIL)))))
(T NIL)))
((EQ (CAR L) 'SETZ)
(COND
((EQ (CAR X) 'SETZ)
; ... (SETZ R1) (SETZ R2) ... ;
(SETQ L ['SETZB (CADR L) (CADR X)])
(SETQ #lap (CDR #lap)))
((AND
(EQ (CAR X) 'JUMPN)
(EQ (CADR X) (CADR L)))
; ... (JUMPN R xxx) (SETZ R) ... ;
(LESCAPE)))))))
(SETQ #lap (CONS L #lap)))
; la fonction *ADD1 est terminee ;
; 14 labels et registres : *RSTL *RESOL *SCR *RCR ;
; resolution des etiquettes multiples ;
(DE *RSTL (L)
; remplace les labels ds la table ;
(SETQ X (CASSQ L LB))
(COND
((NULL X) L)
((LISTP X) X)
(T (*RSTL X))))
(DE *RESOL (L LB ;; X #lap #label)
; resout dans 'L' les etiquettes de 'LB' ;
(OR LB (LESCAPE (FREVERSE L)))
(MAPC LB (FUNCTION (LAMBDA (L) (RPLACD L (*RSTL (CAR L))))))
(MAPC (FREVERSE L)
(FUNCTION (LAMBDA (L)
(COND
((LITATOM L) (OR (ASSQ L LB) (*ADD1 L)))
((EQ (CAR L) 'JRST)
(IF (SETQ X (CASSQ (CADDR L) LB))
(IF (LITATOM X)
(*ADD1 ['JRST 0 X])
(*ADD1 '(POPJ P)))
(*ADD1 L)))
((MEMQ (CAR L) '(JUMPE JUMPN))
(IF (SETQ X (CASSQ (CADDR L) LB))
(*ADD1
[(CAR L)
(CADR L)
(IF (LITATOM X) X ':VPOPJ)])
(*ADD1 L)))
((EQ (CAR L) 'XWD)
; pour les constantes adresses des ESCAPEs ;
(IFN (SETQ X (CASSQ (CADR L) LB))
(*ADD1 L)
(RPLACA (CDR L) (IF (LITATOM X) X ':VPOPJ))
(*ADD1 L)))
(T (*ADD1 L))))))
(IF #label (*RESOL #lap #label) (FREVERSE #lap)))
; sauvegarde et restaurations du contenu des registres ;
(DE *SCR () ; sauvegarde des registres ; (PUSH #ca1))
(DE *RCR () ; restauration des registres ; (SETQ #ca1 (POP)))
; 15 recherches : *OPT ;
(DE *OPT (L R ;; X)
; regarde si L peut se compiler a partir de R ;
(COND
((OR
(ATOM L)
(EQ (CAR L) QUOTE)
(EQ (CAR L) 'LAMBDA)
(EQ (CAR L) 'FUNCTION))
; c'est une constante ou une variable ;
(LE R 4))
((NUMBP (CAR L))
; c'est l'appel d'un CNTH implicit ;
(*OPT (CONS 'CNTH L) R))
((SETQ X (OR (GET (CAR L) 'MACRO)
(GET (CAR L) '!macmp)))
; c'est une macro ;
(*OPT (APPLY X [L]) R))
((SETQ X (GET (NEXTL L) '!cmp))
; c'est une fonction connue ;
(OR (CADR (CDDR X)) (EQ R 1) (LESCAPE))
(SELECTQ (CADR X)
(0SUBR ; SUBR : 0 ARG ; (LE R 4))
(1SUBR ; SUBR : 1 ARG ; (*OPT (CAR L) R))
(2SUBR
; SUBR : 2 ARGS ;
(AND (*OPT (NEXTL L) R) (*OPT (CAR L) (ADD1 R))))
(3SUBR
; SUBR : 3 ARGS ;
(AND
(*OPT (NEXTL L) R)
(*OPT (NEXTL L) (INCR R))
(*OPT (CAR L) (ADD1 R))))
(NSUBR
; NSUBR : N ARGS ;
(EVERY L '(LAMBDA (L) (*OPT L R))))
(FSUBR ; FSUBR : N ARGS ; (LE R 4))
(NIL)))
(T ; fonction inconnue ; NIL) ))
; 16 Recherche des S-exprs communes : *LKM *LK0 *LK1 ;
(DE *LKM (L)
; recherche des sous-expr-commues dans L ;
; et les met dans #ssec qui doit etre initialise a (NIL) ;
(*LK0 L L))
(DE *LK0 (S L)
; explore tous les S avec L ;
(COND
((OR
(ATOM S)
(EQ (CAR S) QUOTE)
(EQ (CAR S) 'FUNCTION)
(ASSOC S #ssec)))
(T (*LK1 S L) (MAPC S (FUNCTION (LAMBDA (S) (*LK0 S L)))))))
(DE *LK1 (S L)
; cherche si S existe dans L ;
(COND
((OR
(ATOM L)
(EQ (CAR L) QUOTE)
(EQ (CAR L) 'FUNCTION)
(EQP L S)))
(T (COND
((EQUAL L S)
(OR
(ASSOC S #ssec)
(LE (*LENS S) 3)
(NCONC1 #ssec [S (GENSYM '%M (INCR CPTSSEC))])))
(T (MAPC L (FUNCTION (LAMBDA (L) (*LK1 S L)))))))))
; 17 table des litteraux #TBL : *PKST *LKT *LKSTBL ;
; La table des litteraux #tbl est organisee comme ;
; une A-liste de type : ([valeur nom] ... [valeur nom]) ;
(DE *PKST (L)
; prepare une constante pour *LKT ;
(IF (ATOM L) [QUOTE L] L))
(DE *LKT (L ;; LAB1)
; recherche le litteral L dans la table ;
; en cre un nouveu s'il n'existait pas ;
; dans tous les cas ramene le nom du litteral ;
(OR
(CAR (CASSOC L #tbl))
(PROGN
(SETQ LAB1 (GENSYM '%T (INCR CPTBL)))
(NCONC1 #tbl [L LAB1])
LAB1)))
(DE *KST (L)
; teste si L se compile en constante ;
(IF (LISTP L)
(EQ (CAR L) QUOTE)
(OR (NUMBP L) (STRINGP L) (MEMQ L -lkst))))
(DE *LKSTBL (L ;; X)
; recherche dans la table des litteraux ;
; la valeur du litteral de nom L ;
(SETQ X #tbl)
(WHILE X
(IF (EQ (CADAR X) L) (LESCAPE (CAAR X)))
(NEXTL X)))))
; 18 otres recherches : -lkst *KST *PKST *LKT *ISARG ;
; definition de la liste des constantes systeme ;
(SETQ
-lkst
(CONS NIL (MAPCT (OBLIST)
'(LAMBDA (L)
(AND (EQ L (CAR L)) (LE (LOC L) (LOC 'STOP)) L)))))
(DE *ISARG (L)
; regarde si dans L yorait pas l'argument de la 1SUBR ;
; Cette fonction est utilisee dans l'amelioration des NSUBRS2 ;
; qui n'empilent pas (mais ne doivent pas detruire #arg1) ;
(IF (NULL #arg1)
NIL
(MAPST L (FUNCTION (LAMBDA (L) (EQ L #arg1))))))
; 19 generation predicat : *CMPREDSTD *CMPRED ;
(DE *CMPREDSTD ()
; compile le predicat d'une maniere standard (cf: *CMPRED) ;
(*CMP L R)
(*ADD1 [(IF TYP 'JUMPN 'JUMPE) R LAB]))
(DE *CMPRED (L R LAB TYP ;; F X LAB1)
; compile le predicat 'L' a partir de 'R' ;
; si 'TYP' = T : JUMP en 'LAB' si 'L' est vrai ;
; si 'TYP' = NIL:JUMP en 'LAB' si 'L' est faux ;
(COND
((ATOM L) (*CMPREDSTD))
((NUMBP (CAR L))
; CNTH implicit ;
(*CMPRED (CONS 'CNTH L) R LAB TYP))
((SETQ X (OR (GET (CAR L) 'MACRO)(GET (CAR L) '!macmp)))
; c'est une macro classique ou du compilateur ;
(*CMPRED (APPLY X [L]) R LAB TYP))
((SELECTQ (CAR L)
((NOT NULL) (*CMPRED (CADR L) R LAB (NOT TYP)))
((LITATOM LISTP ATOM ZEROP NEROP)
(*CMP (CADR L) R)
(*ADD
(SELECTQ (CAR L)
(LITATOM [(IF TYP 'CAMGE 'CAML) R ':BNUMB])
(LISTP [(IF TYP 'CAML 'CAMGE) R ':BLIST])
(ATOM [(IF TYP 'CAMGE 'CAML) R ':BLIST])
(ZEROP [(IF TYP 'CAIN 'CAIE) R ''0])
(NEROP [(IF TYP 'CAIE 'CAIN) R ''0])
(NIL)) ['JRST 0 LAB]))
; y faudrait mettre EQP et NEQP ;
((EQ NEQ)
(IF
(AND
(NOT (STRINGP (CADDR L)))
(OR (NOT (NUMBP (CADDR L))) (INUMBP (CADDR L)))
(*KST (CADDR L)))
(PROGN
(SETQ F (EQ (CAR L) 'EQ))
(SETQ X (IF F TYP (NOT TYP)))
(*CMP (CADR L) R)
(SETQ F (CADDR L))
(*ADD
[(IF X 'CAIN 'CAIE) R (IF (LISTP F) F [QUOTE F])]
['JRST 0 LAB]))
(*CMPREDSTD)))
;;
; attention : la fonction *CMPRED continue ..... ;
; 20 *CMPRED : (suite) ;
;;
((NUMBP INUMBP)
(*CMP (CADR L) R)
(*ADD ['CAML R ':BNUMB]
['CAML
R
(IF (EQ (CAR L) 'INUMBP) ':BCNUM ':BSTRG)])
(AND TYP (*ADD1 '(SKIPA)))
(*ADD1 ['JRST 0 LAB]))
((LEZP LZP GEZP GZP)
(*CMP (CADR L) R)
(*ADD
[(SELECTQ (CAR L)
(LEZP (IF TYP 'SKIPG 'SKIPLE))
(LZP (IF TYP 'SKIPGE 'SKIPL))
(GEZP (IF TYP 'SKIPL 'SKIPGE))
(GZP (IF TYP 'SKIPLE 'SKIPG))
(NIL))
0
':MEM
R] ['JRST 0 LAB]))
((GT GE LT LE)
(COND
((CDDDR L) ; ya plus de 2 args ; (*CMPREDSTD))
((*18BITP (CADDR L))
; le 2eme arg est une constante ;
(SETQ X (GENSYM ':$ (CAR L)))
(IF ?slonum
(*ADD ['PUSHJ 'P (*TWO (CDR L) X)]
['JRST 0 LAB])
(*CMP (CADR L) R)
(*ADD ['MOVE 5 ':MEM R]
[(SELECTQ X
(:$LT (IF TYP 'CAIGE 'CAIL))
(:$LE (IF TYP 'CAIG 'CAILE))
(:$GT (IF TYP 'CAILE 'CAIG))
(:$GE (IF TYP 'CAIG 'CAIGE))
(NIL))
5 (CADDR L)]
['JRST 0 LAB])))
(T (SETQ X (*TWO (CDR L) (GENSYM ':$ (CAR L))))
(IF ?slonum
(*ADD ['PUSHJ 'P X] ['JRST 0 LAB])
(*ADD '(MOVE 5 :MEM 1)
[(SELECTQ X
(:$LT (IF TYP 'CAMGE 'CAML))
(:$LE (IF TYP 'CAMG 'CAMLE))
(:$GT (IF TYP 'CAMLE 'CAMG))
(:$GE (IF TYP 'CAML 'CAMGE))
(NIL))
5
':MEM
2] ['JRST 0 LAB])))))
; 21 *CMPRED : (suite) ;
;;
(STRINGP
(*CMP (CADR L) R)
(*ADD ['CAML R ':BSTRG] ['CAML R ':BLIST])
(AND TYP (*ADD1 '(SKIPA)))
(*ADD1 ['JRST 0 LAB]))
(MEMQ
(IF
(AND
(LISTP (CADDR L))
(EQ (CAR (CADDR L)) QUOTE)
(EVERY (CADR (CADDR L)) '*UNIQUEP))
(PROGN
(*CMP (CADR L) R)
(SETQ LAB1 (GENSYM) L (CADR (CADDR L)))
(WHILE L
(*ADD1 [(IF TYP 'CAIN 'CAIE)
R
[QUOTE (NEXTL L)]])
(AND
L
(*ADD
[(IF TYP 'CAIE 'CAIN) R [QUOTE (NEXTL L)]]
['JRST 0 LAB1])))
(*ADD ['JRST 0 LAB] LAB1))
(*CMPREDSTD)))
((OR AND)
(SETQ F (EQ (NEXTL L) 'OR) X (IF F TYP (NOT TYP)))
(OR X (SETQ LAB1 (GENSYM)))
(WHILE (CDR L)
(*CMPRED (NEXTL L) R (IF X LAB LAB1) F))
(*CMPRED (CAR L) R LAB (IF X F (NOT F)))
(OR X (*ADD1 LAB1))
(SETQ #ca1))
((*CMPREDSTD))))))
; 22 gener. speciale : *NIEWIEM *PA1 *LAMBDA *PROGN *TWO ;
(DE *NIEWIEM (L R)
; on ne connait rien sur L !?! ;
(IF (NEQ R 1)
(COMPILERROR '*NIEWIEM L R)
(*ADD ['MOVEI 1 [QUOTE L]] '(PUSHJ P EVAL))))))
(DE *PA1 (L)
; compile L dans 1 et l'empile ;
(IF (*KST L)
(*ADD ['PUSH 'P (*LKT (IF (ATOM L) [QUOTE L] L))])
(*CMP L 1)
(*ADD1 '(PUSH P 1)))
(INCR #stk))
(DE *LAMBDA (L ;; X)
; compile une LAMBDA-EXPR explicite ou fonctionnelle ;
; L = ((LVAR) BODY ) . ramene un nom de fonction GENSYME ;
; doit sauver et restaurer #stk pour les 'LESCAPES' ;
(PUSH #stk)
(SETQ #stk 0)
(SETQ X (GENSYM '%F (INCR CPTFNT) #namefnt))
(NCONC #lap (FREVERSE (COMPIL (MCONS 'DE X L))))
(SETQ #stk (POP))
X)
(DE *PROGN (L R F)
; compile le PROGN L a partir de R. ;
; F = T si une valeur est toujours requise ;
(WHILE (LISTP (CDR L))
; compil pour les effets ;
(*CMP (NEXTL L) R T))
; le dernier peut se compiler pour sa valeur ;
(*CMP (CAR L) R (IF F NIL ?ef)))
; 23 : gener. speciale : *TWO ;
(DE *TWO (L F ;; X)
; prepare les 2 arguments de la 2SUBR F ;
(COND
((*OPT (CADR L) (ADD1 R))
; cas le + favorable : ;
; le 2eme arg peut se compiler dans A2 (e.g.) ;
(*CMP (NEXTL L) R)
(*CMP (CAR L) (ADD1 R)))
((*KST (CAR L))
; le 1er argument est une constante ;
(*CMP (CADR L) R)
(IF (SETQ X (GET F '!commut))
; c'est commutatif ;
(LESCAPE (*CMP (CAR L) (ADD1 R)) X)
; ca l'est pas ;
(*ADD1 ['MOVEI (ADD1 R) 0 R])
(*CMP (CAR L) R)))
(T ; cas le - favorable : ;
; il fo empiler le 2eme pour compiler le 1er ;
(*PA1 (NEXTL L))
(*CMP (CAR L) R)
(DECR #stk)
(IFN (SETQ X (GET F '!commut))
(*ADD ['MOVEI (ADD1 R) 0 R] ['POP 'P R])
(*ADD1 ['POP 'P (ADD1 R)])
(LESCAPE X))))
F)
; 24 : DGEN ;
; Les fonctions de type DGEN sont de petits specialistes ;
; lances par la fonction *CMP. Ils ont une liaison de type ;
; MACRO (i.e. c'est l'appel tout entier qui est lie au 1er arg.) ;
(DF DGEN (L)
; permet de declarer 1 (ou plusieurs) fnts DGEN ;
(IF (ATOM (CAR L))
(PUT (CAR L) (CONS LAMBDA (CDR L)) '!gen)
(MAPC (CAR L) (LAMBDA (X)
(PUT X (CONS LAMBDA (CDR L)) '!gen)))))
(DE *DGEN2 (L)
; auxilliaire des DGENs a 2 arguments ;
; compil l'appel standard d'une 2SUBR. ;
(*ADD1 ['PUSHJ 'P (*TWO (CDR L) (CAR L))]))
; TOUTES les fonctions DGEN qui suivent sont triees par ordre ;
; alphabetique. Les variables globales utilisees par ces fonctions : ;
; - R : registre dans lequel doit se trouver la valeur de la ;
; fonction. R est lie dans *CMP. ;
; ?ef : indicateur = T si les effets seuls de la fonction compte ;
; (et non la aleur de la fonction). ;
; 25 : fnts DGENs : ;
; (DGEN CNTH ..... ) cf: NTH ;
(DGEN (NTH CNTH) (L)
(IFN ?open (*DGEN2 L)
(IF (NUMBP (CADR L))
(PROGN (*CMP (CADDR L) R)
(*ADD1 ['SKIPA 5 ':MEM [QUOTE (CADR L)]]))
(*TWO (CDR L) R)
(*ADD ['EXCH R (ADD1 R)] ['SKIPA 5 ':MEM (ADD1 R)]))
(*ADD ['CDR R R] ['CAML R ':BLIST] ['SOJG 5 '(* -2)])
(IF (EQ (CAR L) 'CNTH) (*ADD1 ['CAR R R])))))))
; 26 *GEN0SUBR *GEN1SUBR ;
(DE *GEN0SUBR ()
; generation des 0SUBRs open (si flag ?open). ;
; Utilise les memes variables que *GEN. ;
(SELECTQ F
(TYI (*ADD '(\51 0 5) ; (TTCALL 0 5) ;
'(JSP L :$CRANB)))
(:$POP (*ADD '(SOS 5 :USTCKC) '(CAMGE 5 :USTCKB)
'(JRST 0 :ERSU) ['MOVE R 1 5]))
(:$PSTACK (*ADD '(MOVE 5 :USTCKC) '(JSP L :$CRANB)))
((*ADD1 ['PUSHJ 'P F]))))
(DE *GEN1SUBR ()
; Generation des 1SUBRs open (si flag ?open). ;
; Utilise les memes variables que *GEN. ;
(SELECTQ F
(ATOM
(*ADD ['CAML R ':BLIST] ['TDZA R R] ['MOVEI R ''T]))
(DIM (IF ?ckarray '(PUSHJ P DIM)
(*ADD ['HRRZ 5 R] ['MOVE R 0 5])))
(ID NIL)
(LENGTH (*ADD '(TDZA 5 5) ['CDR R R] ['CAML R ':BLIST]
'(AOJA 5 (* -2)) '(JSP L :$CRANB)))
(LITATOM (*ADD ['CAML R ':BNUMB] ['TDZA R R] ['MOVEI R ''T]))
(LISTP (*ADD ['CAMGE R ':BLIST] ['TDZA R R] ['MOVEI R ''T]))
(NCONS (*ADD ['HRLZ R R]
['EXCH R ':MEM 'FREE] ['EXCH 'FREE R]))
((NOT NULL) (*ADD ['JUMPE R '(* 2)] ['TDZA R R] ['MOVEI R ''T]))
(NUMBP (*ADD ['CAML R ':BNUMB] ['CAML R ':BSTRG]
['SETZ R]))
(TYO (*ADD1 [\51 1 ':MEM R]))
(:$PUSH (*ADD '(AOS 5 :USTCKC) '(CAML 5 :USTCKE)
'(JRST 0 :ERSO) ['MOVEM R 0 5]))
((*ADD1 ['PUSHJ 'P F]))))
; 27 *GEN2SUBR ;
(DE *GEN2SUBR ()
; Generation des 2SUBRs open (si flag ?open). ;
; Utilise les memes variables que *GEN. ;
(SELECTQ X
(CONS (*ADD ['HRL N R]
['EXCH N ':MEM 'FREE] ['EXCH 'FREE N] ['MOVEI R 0 N]))
(EQP (*ADD ['CAIE R 0 N] ['TDZA R R] ['MOVEI R ''T]))
(:$GE (*ADD ['MOVE 8 ':MEM R] ['CAMGE 8 ':MEM N] ['SETZ R]))
(:$GT (*ADD ['MOVE 8 ':MEM R] ['CAMG 8 ':MEM N] ['SETZ R]))
(:$LE (*ADD ['MOVE 8 ':MEM R] ['CAMLE 8 ':MEM N] ['SETZ R]))
(:$LT (*ADD ['MOVE 8 ':MEM R] ['CAML 8 ':MEM N] ['SETZ R]))
(NEQP (*ADD ['CAIN R 0 N] ['TDZA R R] ['MOVEI R ''T]))
(:$MAX (*ADD ['MOVE 5 ':MEM R] ['CAMGE R ':MEM N]
['MOVEI R 0 N]))
(:$MIN (*ADD ['MOVE 5 ':MEM R] ['CAML R ':MEM N]
['MOVEI R 0 N]))
(RPLACB (*ADD ['MOVE (ADD1 N) ':MEM N] ['MOVEM (ADD1 N) ':MEM R]))
(XCONS (*ADD ['HRL R N]
['EXCH R ':MEM 'FREE] ['EXCH 'FREE R]))
((*ADD1 ['PUSHJ 'P X]))))
; 28 *GEN : QUOTE 0SUBR 1SUBR 1SUBRS 2SUBR ;
(DE *GEN (P F L R ;; N X LAB1 LAB2 LAB3 LAB4 FLG1 FLG2)
; genere le code d'une fonction connue : ;
; - P = type de la fonction ;
; - F = nom de la fonction ;
; - L = liste des arguments ;
; - R = numero du 1er registre utile ;
(SELECTQ P
(QUOTE
;;
; - OPEN - : QUOTE ;
;;
(*ADD1 ['MOVEI R [QUOTE (CAR L)]]))
(0SUBR
;;
; SUBRS a 0 arg non open ;
;;
(IF ?open (*GEN0SUBR) (*ADD1 ['PUSHJ 'P F])))
(1SUBR
;;
; SUBRS a 1 arg non open ;
;;
(*CMP (CAR L) R)
(IFN ?open (*ADD1 ['PUSHJ 'P F]) (*GEN1SUBR)))
(1SUBRS
;;
; SUBRS a 1 arg qui n'en ont pas ;
;;
(IFN L
(*CMP [(GENSYM ':$ F)])
(*CMP (CAR L) R)
(*ADD1 ['PUSHJ 'P F])))
(2SUBR
;;
; SUBRS a 2 args non open ;
;;
(SETQ X (*TWO L F))
(SELECTQ F
(RPLACA (*ADD1 ['RPLACA R (ADD1 R)]))
(RPLACD (*ADD1 ['RPLACD R (ADD1 R)]))
((IFN ?open (*ADD1 ['PUSHJ 'P X])
(SETQ N (ADD1 R)) (*GEN2SUBR)))))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 29 *GEN : 1SUBARITH 2SUBRARITH ;
;;
(1SUBRARITH
; SUBRs arithmetiques a 1 argument ;
(*CMP (CAR L) 1)
(IF ?slonum
(*ADD ['PUSHJ 'P F])
(IF (MEMQ F '(ADD1 SUB1)) (*ADD1 '(MOVE 5 :MEM 1)))
(*ADD
(SELECTQ F
(ADD1 '(ADDI 5 1))
(SUB1 '(SUBI 5 1))
(ABS '(MOVM 5 :MEM 1))
(MINUS '(MOVN 5 :MEM 1))
(COMPL '(SETCM :MEM 1))
(SWAP '(MOVS 5 :MEM 1))
((COMPILERROR '*GEN '1SUBRARITH P F L R)))
'(JSP L :$CRANB))))
(2SUBRARITH
;;
; SUBRs arithmetique a 2 arguments ;
;;
(COND
(?slonum (*ADD1 ['PUSHJ 'P (*TWO L F)]))
((AND (NUMBP (CAR L)) (GEZP (CAR L)) (*18BITP (CAR L)))
; le 1er op est une val immediate ;
(*CMP (CADR L) 1)
(*ADD ['MOVEI 5 (CAR L)]
[(CASSQ F -laritha) 5 ':MEM 1]
'(JSP L :$CRANB)))
((AND (NUMBP (CADR L))
(GEZP (CADR L))
(*18BITP (CADR L)))
; le 2eme op est une val immediate ;
(*CMP (CAR L) 1)
(*ADD '(MOVE 5 :MEM 1)
[ (CASSQ F -larithi) 5 (CADR L)]
'(JSP L :$CRANB)))
(T ; ya pas de val immediate ;
(SETQ X (*TWO L F))
(*ADD '(MOVE 5 :MEM 1)
[ (CASSQ X -laritha) 5 ':MEM 2]
'(JSP L :$CRANB)))))
;;
; ATTENTION : la fonction :GEN continue ..... ;
; 30 *GEN : 3SUBR ;
;;
(3SUBR
;;
; SUBRS a 3 args non open ;
; si ya des 3SUBRs open yfo changer les nos des regs ;
;;
(COND
((AND (*OPT (CADR L) 2) (*OPT (CADDR L) 3))
; cas le + favorable : on sauve rien ;
(*CMP (NEXTL L) 1)
(*CMP (NEXTL L) 2)
(*CMP (CAR L) 3))
((*KST (CAR L))
; le 1er argument est une constante ;
(COND
((*KST (CADR L))
; 1er et 2eme constante ;
(*CMP (CADDR L) 1)
(*ADD1 '(MOVEI 3 0 1))
(*CMP (CAR L) 1)
(*CMP (CADR L) 2))
((OR (*KST (CADDR L)) (*OPT (CADDR L) 3))
; 1er et 3eme constante ;
(*CMP (CADR L) 1)
(*ADD1 '(MOVEI 2 0 1))
(*CMP (CAR L) 1)
(*CMP (CADDR L) 3))
(T ; le 1er seul est une constante ;
(*PA1 (CADR L))
(*CMP (CADDR L) 1)
(*ADD '(MOVEI 3 0 1) '(POP P 2))
(DECR #stk)
(*CMP (CAR L) 1))))
((*KST (CADR L))
; le 2eme seul est une constante ;
(*PA1 (CAR L))
(*CMP (CADDR L) 1)
(*ADD '(MOVEI 3 0 1) '(POP P 1))
(DECR #stk)
(*CMP (CADR L) 2))
((OR (*KST (CADDR L)) (*OPT (CADDR L) 3))
; le 3eme seul est une constante ;
(*TWO L)
(*CMP (CADDR L) 3))
(T ; cas le plus defavorable : il faut ;
; empiler les 2 1ers args ;
(*PA1 (NEXTL L))
(*PA1 (NEXTL L))
(*CMP (CAR L) 1)
(SETQ #stk (DIFFER #stk 2))
(*ADD '(MOVEI 3 0 1) '(POP P 2) '(POP P 1))))
(*ADD1 ['PUSHJ 'P F]))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 31 *GEN : NSUBR NSUBR1 NSUBR2 STATUS FSUBR ;
;;
(NSUBR
;;
; SUBRS a N args non open ;
;;
(IF (NULL L)
(*ADD '(SETZ 4) ['PUSHJ 'P F])
(PUSH #stk)
(INCR #stk)
(*ADD1 ['PUSH 'P (*LKT ['XWD -1 F])])
(WHILE (CDR L) (*PA1 (NEXTL L)))
(*CMP (CAR L) 1)
(*ADD1 '(JSP L :NSUBR))
(SETQ #stk (POP))))
(NSUBRS1
;;
; SUBRS a N args qui en general n'en ont k1 ;
;;
(IF (CDR L)
(*GEN (IF (EQ F 'PRINC) '2SUBR 'NSUBR) F L R)
(*CMP (CAR L) R)
(*ADD1 ['PUSHJ 'P (GENSYM ':$ F)])))
(NSUBRS2
;;
; SUBRs a N arguments qui en general n'en ont que 2 ;
;;
(IF (OR (CDDR L) ;(*ISARG L);)
(*GEN 'NSUBR F L R)
(*ADD1 ['PUSHJ 'P (*TWO L (GENSYM ':$ F))])))
(STATUS
;;
; fonction speciale STATUS ;
;;
(COND
((NULL (CDR L)) (*GEN '1SUBR ':$1STATUS L R))
((NULL (CDDR L)) (*GEN '2SUBR ':$2STATUS L R))
((NULL (CDDDR L)) (*GEN '3SUBR ':$3STATUS L R))
(T (*GEN 'NSUBR 'STATUS L R))))
(FSUBR
;;
; FSUBR non open ;
;;
(*ADD ['MOVEI 1 [QUOTE L]] ['PUSHJ 'P F]))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 32 *GEN : CONS SELF C...R OR ;
;;
(CONS
;;
; cas special du CONS ;
;;
(IF (OR (*KST (CAR L))
(AND (ATOM (CAR L))
(ATOM (CADR L))))
; le XCONS permet de gagner le dernier transfert du CONS ;
(*CMP ['XCONS (CADR L) (CAR L)] R)
(*GEN '2SUBR 'CONS L R)))
(SELF
;;
; y suffit de changer le nom de la fonction ;
;;
(*CMP (CONS #namefnt L) R))
(CAR
;;
; CAR ... CDDDR : - open - ;
;;
(*CMP (CAR L) R)
(SETQ F (CDR (FREVERSE (EXPLODE F))))
(UNTIL (EQ (CAR F) 'C)
(*ADD1 [(IF (EQ (NEXTL F) 'A) 'CAR 'CDR) R R])))
(OR
;;
; OR AND : - open - ;
;;
(SETQ
LAB1 (GENSYM)
X [(IF (EQ F 'OR) 'JUMPN 'JUMPE) R LAB1])
(WHILE (CDR L)
(IF ?ef
(*CMPRED (NEXTL L) R LAB1 (EQ F 'OR))
(*CMP (NEXTL L) R)
(*ADD1 X)))
(*CMP (NEXTL L) R ?ef)
(*ADD1 LAB1))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 33 *GEN : ARRAY SETQA ;
;;
(ARRAY
;;
; element d'un tableau ;
;;
(IF (NUMBP (CAR L))
(*ADD ['ARRAY 5 F] ['MOVE R (ADD1 (CAR L)) 5])
(*CMP (CAR L) R)
(IF ?ckarray
(*ADD ['MOVEI 2 [QUOTE F]] '(PUSHJ P :CMPELM))
(*ADD ['ARRAY 5 F] ['ADD 5 ':MEM R] ['MOVE R 1 5]))))
(SETQA
;;
; affectation d'un element de tableau ;
;;
(IF ?ckarray
(*ADD ['MOVEI 1 [QUOTE L]] '(PUSHJ P SETQA))
(COND
((NUMBP (CADR L))
; l'indice est un constante ;
(IF (AND ?ef (NULL (CADDR L)))
(*ADD ['ARRAY 5 (CAR L)]
['SETZM 0 (ADD1 (CADR L)) 5 ])
(*CMP (CADDR L) R)
(*ADD ['ARRAY 5 (CAR L)]
['MOVEM R (ADD1 (CADR L)) 5])))
(T ; L'indice est a calculer ;
(*TWO (CDR L))
(*ADD ['ARRAY 5 (CAR L)] ['ADD 5 ':MEM R]
['MOVEM (ADD1 R) 1 5])
(OR ?ef (*ADD1 ['MOVEI R 0 (ADD1 R)])) ))))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 34 *GEN : IF PROGN DE ;
;;
(IF
;;
; IF IFN : - open - ;
;;
(SETQ LAB1 (GENSYM) LAB2 (GENSYM))
(*CMPRED (NEXTL L) R LAB1 (EQ F 'IFN))
(IF
(AND
(*KST (CAR L))
(CDR L)
(*KST (CADR L))
(NULL (CDDR L)))
; ... (IF pred const1 const2) ... ;
(IF (NEQUAL (CAR #lap) ['JRST 0 LAB1])
(*ADD ['SKIPA R (*LKT (*PKST (NEXTL L)))] LAB1
['MOVEI R (*PKST (CAR L))])
(SETQ #lap (CDR #lap))
; y faudrait prevoir SKIPA ;
(*ADD (IF (CADR l)
['SKIPA R (*LKT (*PKST (CADR L)))]
['TDZA R R])
['MOVEI R (*PKST (CAR L))]))
(*SCR)
(*CMP (NEXTL L) R ?ef)
(*RCR)
(IF (AND (NULL L) ?ef)
; ... (IF Pred then) ... ;
(*ADD1 LAB1)
; ... (IF pred then else1 ... elseN) ... ;
(*ADD ['JRST 0 LAB2] LAB1)
(*PROGN L R)
(*ADD1 LAB2))))
(PROGN ;; ; PROGN : - open - ; ;; (*PROGN L R))
(DE
;;
; DE DF DM DMI DMO : equivalent a un PUT ;
;;
(REMPROP (CAR L) '!cmp)
(*GEN '3SUBR 'PUT
[[QUOTE (NEXTL L)]
[QUOTE (CONS 'LAMBDA L)]
[QUOTE
(CASSQ F
'((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DMI . MACIN)
(DMO . MACOUT)))]] 1))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 35 *GEN : COND ;
;;
(COND
;;
; COND : - open - ;
;;
(IF (NEQ (CAAR (LAST L)) T)
; pour eviter *ER A3 ;
(SETQ L (APPEND L '((T NIL)))))
(SETQ LAB1 (GENSYM) LAB2 (GENSYM))
(WHILE (SETQ N (NEXTL L))
(COND
((EQ (CAR N) T)
; clause 'T' ;
(IF (CDR N)
(*PROGN (CDR N) R)
(*ADD1 ['MOVEI R [QUOTE T]])))
((CDR N)
; clause normale pleine ;
(*CMPRED (NEXTL N) R (IF L LAB2 LAB1) NIL)
(*SCR)
(*PROGN N R)
(*RCR))
(T ; clause vide ;
(IF (NOT L)
; c'est la derniere clause du COND ;
(*CMP (NEXTL N) R ?ef)
; c'est au milieu du COND ;
(IF ?ef
; les effets seuls comptent ;
(*CMPRED (NEXTL N) R LAB1 T)
; le COND doit ramener une valeur ;
(*CMP (NEXTL N) R)
(*ADD1 ['JUMPN R LAB1])))))
(AND
L
N
(PROGN
(*ADD ['JRST 0 LAB1] LAB2)
(SETQ LAB2 (GENSYM)))))
(*ADD1 LAB1))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 36 *GEN : SELECTQ ;
;;
(SELECTQ
;;
; SELECTQ : - open - ;
;;
; FLG1 = T ya u un push, FLG2 = T le select est detruit ;
(SETQ LAB1 (GENSYM) LAB2 (GENSYM))
(*CMP (NEXTL L) 1)
(WHILE (LISTP (CDR L))
(SETQ N (NEXTL L) X (NEXTL N))
(COND
((*UNIQUEP X)
(AND
FLG1
FLG2
(PROGN (*ADD1 '(MOVE 1 -1 P)) (SETQ FLG2)))
(*ADD ['CAIE 1 [QUOTE X]] ['JRST 0 LAB2]))
((AND (LISTP X) (EVERY X '*UNIQUEP))
; macrogeneration du MEMQ ;
(AND FLG2 (*ADD1 '(MOVE 1 -1 P)))
(SETQ LAB4 (GENSYM))
(WHILE X
(*ADD1 ['CAIE R [QUOTE (NEXTL X)]])
(AND
X
(*ADD ['CAIN R [QUOTE (NEXTL X)]]
['JRST 0 LAB4])))
(*ADD ['JRST 0 LAB2] LAB4))
(T (OR
FLG1
(PROGN
(INCR #stk)
(*ADD1 '(PUSH P 1))
(SETQ FLG1 T LAB3 (GENSYM))))
(AND FLG2 (*ADD1 '(MOVE 1 -1 P)))
(*ADD ['MOVEI 2 [QUOTE X]]
['PUSHJ 'P (IF (ATOM X) 'EQ 'MEMBER)]
['JUMPE 1 LAB2])
(SETQ FLG2 T)))
(*PROGN N 1)
(*ADD ['JRST 0 (IF FLG1 LAB3 LAB1)] LAB2)
(SETQ LAB2 (GENSYM)))
(*PROGN (CAR L) 1)
(AND FLG1 (DECR #stk) (*ADD LAB3
['SUB 'P (*LKT '(XWD 1 1))] ))
(*ADD1 LAB1))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 37 *GEN : ESCAPE LESCAPE WHILE ;
;;
(ESCAPE
;;
; ESCAPE : - open - ;
;;
(SETQ LAB1 (GENSYM) LAB2 (GENSYM))
(SETQ #esc (CONS (CONS (CAR L) LAB1) #esc))
(*ADD '(JSP L :ESBIND) ['XWD LAB2 [QUOTE (CAR L)]])
(*PROGN (CDR L) 1 T)
(*ADD LAB1 ['MOVEI 2 [QUOTE (CAR L)]] '(JRST 0 :ESCAPT)
LAB2)
(SETQ #esc (CDR #esc)))
(LESCAPE
;;
; LESCAPE : - open - ;
;;
(*PROGN L 1 T)
(OR
(ZEROP #stk)
(*ADD1 ['SUB 'P (*LKT ['XWD #stk #stk])]))
(*ADD1 '(POPJ P)))
(WHILE
;;
; WHILE UNTIL : - open - ;
;;
(SETQ LAB1 (GENSYM) LAB2 (GENSYM))
(SETQ
X (NEXTL L)
FLG1 (IF (EQ F 'WHILE) (EQ X T) (NULL X))
FLG2 (NULL L))
(OR FLG1 FLG2 (*ADD ['JRST 0 LAB2]))
(OR FLG2 (*ADD LAB1))
; le corps n'est a compiler que pour les effets ;
(SETQ #ca1)
(OR FLG2 (WHILE L (*CMP (NEXTL L) R T)))
(SETQ #ca1)
(IF FLG1
(*ADD1 ['JRST 0 LAB1])
(*ADD1 LAB2)
(*CMPRED X R (IF FLG2 LAB2 LAB1) (EQ F 'WHILE))))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 38 *GEN : REPEAT NEXTL SETQ SETQQ ;
;;
(REPEAT
;;
; REPEAT : - open - ;
;;
(SETQ LAB1 (GENSYM) LAB2 (GENSYM))
(IF (NUMBP (CAR L))
(*ADD ['PUSH 'P (*LKT ['EXP (MINUS (NEXTL L))])])
(*CMP (NEXTL L) R)
(*ADD '(MOVN 5 :MEM 1) '(PUSH P 5)))
(*ADD ['JRST 0 LAB2] LAB1)
(INCR #stk)
(SETQ #ca1)
(*PROGN L R)
(*ADD LAB2 '(AOSG 0 0 P) ['JRST 0 LAB1]
['SUB 'P (*LKT '(XWD 1 1))])
(DECR #stk))
(NEXTL
;;
; NEXTL : - open - ;
;;
(IF ?ef
(*CMP ['SETQ (CAR L) ['CDR (CAR L)]] R)
(*CMP (CAR L) (ADD1 R))
(*ADD ['CAR R (ADD1 R)]
['CDR (ADD1 R) (ADD1 R)]
['PUTVAL (ADD1 R) (CAR L)])))
(SETQ
;;
; SETQ : - open ;
;;
(WHILE L
(IF (AND ?ef (NULL (CADR L)))
; (SETQ var NIL) ;
(*ADD1 ['SETNIL (CAR L)])
; (SETQ var expression) ;
(*CMP (CADR L) R)
(*ADD1 ['PUTVAL R (CAR L)]))
(SETQ #ca1 (NEXTL L) L (CDR L))))
(SETQQ
;;
; SETQQ : - open - ;
;;
(WHILE L
(*ADD ['MOVEI R [QUOTE (CADR L)]] ['PUTVAL R (NEXTL L)])
(SETQ L (CDR L))))
;;
; ATTENTION : la fonction *GEN continue ..... ;
; 39 *GEN : FUNCTION LAMBDA MAPC ;
;;
(FUNCTION
;;
; FUNCTION : - open - en creant un nom de fonction gensyme ;
;;
(*ADD1
['MOVEI
R
[QUOTE
(COND
((ATOM (CAR L)) (CAR L))
((EQ (CAAR L) LAMBDA) (*LAMBDA (CDAR L)))
(T (CAR L)))]]))
(LAMBDA
;;
; LAMBDA : - open - cf: FUNCTION ;
;;
(*ADD1 ['MOVEI R [QUOTE (*LAMBDA L)]]))
(MAPC
;;
; MAPC MAP : - open si LAMBDA explicite ;
;;
(*TWO L F)
(*ADD1
['PUSHJ
'P
(IF (OR
(LITATOM (CADR L))
(NOT (MEMQ (CAADR L) '(FUNCTION LAMBDA))))
F
(SETQ X (GET (CADAR (CDDAR #lap)) '!cmp))
(SELECTQ (CADR X)
((1SUBR 2SUBR 3SUBR)
(IF (EQ F 'MAP) ':$MAP1 ':$MAPC1))
((IF (EQ F 'MAP) ':$MAPN ':$MAPCN))))]))
((COMPILERROR '*GEN P F L R ))))
; la fonction *GEN est terminee ;
; 40 fonction de compilation : *CMP ;
(DE *CMP (S R ?ef ;; X)
; compile la S-expr S a partir de R ;
; ?ef = T si l'effet seul est recherche (non pas la valeur) ;
(AND #ca1 (EQUAL #ca1 S)
(LESCAPE (OR (EQ R 1) (*ADD1 ['MOVEI R 0 1]))))
(COND
((NULL S) (OR ?ef (*ADD1 ['SETZ R])))
((MEMQ S -lkst) (*ADD1 ['MOVEI R [QUOTE S]]))
((LITATOM S) (*ADD1
(IF (AND (EQ #ca1 S)(EQ R 1))
['MOVEI R 0 1]
['GETVAL R S])))
((ATOM S) (*ADD1 ['MOVEI R [QUOTE S]]))
((NUMBP (CAR S))
; CNTH implicite ;
(SELECTQ (CAR S)
; on traite d'abord les cas simples ;
(1 (*GEN 'CAR 'CAR (CDR S) R))
(2 (*GEN 'CAR 'CADR (CDR S) R))
(3 (*GEN 'CAR 'CADDR (CDR S) R))
(4 (*GEN 'CAR 'CADDDR (CDR S) R))
; cas le plus complique ;
((*GEN '2SUBR 'CNTH S R))))
((AND (NOT M) (EQ R 1) (SETQ X (ASSOC S #ssec)))
; c'est une sous-expr-commune ;
( (LAMBDA (Z)
(IF (CDDR X)
; elle a deja ete marque ;
(*ADD1 ['PUSHJ 'P (CADR X)])
(SETQ Z (COMPIL S T))
(IF (LE (LENGTH Z) 3)
; elle est vraiment trop petite ;
(PROGN (RPLACA X NIL) (*CMP S R ?ef))
; on la stocke ;
(RPLACD (CDR X) Z)
(*ADD1 ['PUSHJ 'P (CADR X)]))))))
((SETQ X (CASSQ (CAR S) #esc))
; c'est l'appel d'un ESCAPE actif ;
(*CMP (CONS 'PROGN (CDR S)) R)
(*ADD1 ['JRST 0 X]))
((SETQ X (OR (GET (CAR S) 'MACRO) (GET (CAR S) '!macmp)))
; c'est une macro classique ou du compilateur ;
(LESCAPE (*CMP (APPLY X [S]) R ?ef)))
((SETQ X (GET (CAR S) '!gen))
; specialistes de generation ;
(APPLY X [S]))
((LITATOM (CAR S))
(IF (SETQ X (GET (CAR S) '!cmp))
(*GEN (CAR X) (CAR S) (CDR S) R)
(*ADD ['MOVEI R [QUOTE S]] '(PUSHJ P EVAL))))
((AND (LISTP (CAR S)) (EQ (CAAR S) LAMBDA))
; ... ((LAMBDA (LVAR) BODY) LARG) ... ;
(*CMP (CONS (*LAMBDA (CDAR S)) (CDR S)) R))
((*NIEWIEM S R)))
(SETQ
#ca1
(IF (ATOM S)
(AND (LITATOM S) (EQ R 1) S)
(SELECTQ (CAR S)
((CAR CDR CAAR CADR CDAR CDDR)
(AND (LITATOM (CADR S)) S))
(SETQ
(NEXTL S)
(WHILE (LISTP (CDDR S)) (SETQ S (CDDR S)))
(CAR S))
(NIL)))))
; 41 impressions : *LENS *LENL PRCOMMENT PRMAC ;
(DE *LENS (S)
; calcul le nb de doublets de la S-expr 'S' ;
(COND
((ATOM S) 1)
((EVERY S 'ATOM) (ADD1 (LENGTH S)))
((APPLY 'PLUS (CONS 1 (MAPCAR S '*LENS))))))
(DE *LENL (L ;; N)
; calcul le nb d'instructions LAP de L ;
(SETQ N 0)
(WHILE L
(OR
(LITATOM (NEXTL L))
(AND (LISTP L) (NEQ (CAR L) 'ENTRY) (INCR N))))
N)
(DF PRCOMMENT (evl)
; edite entre points et virgules ;
(PRINC (ASCII 59))
(EPROGN evl)
(SPACES 1)
(PRINC (ASCII 59)))
(DE PRSSEC (;; X)
; impression des sous-expr-commues ;
; ramene la liste du code des ssecs prete pour le LAP ;
(OR (CDR #ssec) (LESCAPE))
(SETQ X (CONS))
(IF ?sw1
(PROGN
(PRCOMMENT (PRINC '- 10) (APPLY 'PRIN1 (EXPLODE '#ssec))
(TERPRI) (PRIN1 '#ssec 'LENGTH '= (LENGTH (CDR #ssec))))
(TERPRI 2)))
(MAPC (CDR #ssec)
'(LAMBDA (S)
(OR (CDDR S) (LESCAPE))
(NCONC X (CDR S))
(IF ?sw1
(PROGN
(PRCOMMENT (PRETTYP (NEXTL S)) (PRINC (ASCII 59)))
(PRLAP (CONS (NEXTL S) S))))))
(IF ?sw1 (TERPRI))
(CDR X))
; 42 impressions : PRTBL PRCOD ;
(DE PRTBL (;; X)
; imprime la table des constantes ;
; ramene la liste des constantes prete pour le LOAD ;
(OR (CDR #tbl) (LESCAPE))
(STATUS 1 24) ; inclusion des / ;
(IF ?sw1
(PROGN
(PRCOMMENT (PRINC '- 10) (APPLY 'PRIN1 (EXPLODE '#tbl))
(TERPRI) (PRIN1 '#tbl 'LENGTH '= (LENGTH (CDR #tbl))))
(TERPRI 2)))
(MAPC (CDR #tbl)
(LAMBDA (S)
(SETQ X (CONS (CAR S) (CONS (CADR S) X)))
(IFN ?sw1
(PRINT (CADR S) (CAR S))
(STATUS 1 24)
(PRIN1 (CADR S))
(STATUS 7 15)
(PRIN1 (CAR S))
(STATUS 7 0)
(TERPRI))))
(IF ?sw1 (TERPRI 2))
(STATUS 2 24)
(FREVERSE X))
(DE PRCOD (S L)
; imprime le clair d'un objet gensyme ;
(AND (LT (STATUS 8) 25) (TTAB 25) (STATUS 7 25))
(PRCOMMENT (PRIN1 (CAR (CNTH (ADD1 (APPLY 'GENSYM S)) L)))))
; 43 impressions : PRLAP SORTL ;
(DE PRLAP (L ;; S)
; imprime du LAP qu'est dans L ;
(STATUS 1 24)
(IFN ?sw1
(MAPC L 'PRIN1)
(WHILE L
(IF (ATOM (CAR L))
(PRINT (NEXTL L))
(AND
(EQ (CAAR L) 'ENTRY)
(PRINC (ASCII 59) 6)
(TERPRI))
(SPACES 6)
(STATUS 7 15)
(PRIN1 (SETQ S (NEXTL L)))
(AND
(SETQ S (EXPLODE (CADDR S)))
(EQ (NEXTL S) '%)
(EVERY (CDR S) 'NUMBP)
(SELECTQ (NEXTL S)
(T (PRCOD S #tbl))
(M (PRCOD S #ssec))
(NIL)))
(STATUS 7 0)
(TERPRI))))
(TERPRI)
(STATUS 2 24)))
(DE SORTL (L ;; X)
; tri la liste d'atomes L ;
(MAP L (LAMBDA (SL)
(AND (CDR SL) (MAP (CDR SL)
(LAMBDA (SL1) (OR (SORT (CAR SL) (CAR SL1))
(PROGN (SET 'X (CAR SL) SL (CAR SL1))
(RPLACA SL1 X))))))))
L)
; 44 fnts principales : COMPIL ;
(DE COMPIL (L M ;; #lap #label #ca1 #arg1 #namefnt)
; compile L et ramene une liste #lap ;
; en ignorant tout ce qui a deje ete fait ;
; M = T si L est une sous-expr-commune ;
; #tbl ET #ssec doivent etre charges ;
; #ca1 contenu couranr de A1 ;
; #arg1 nom du 1er arg si 1SUBR ;
; #namefnt : nom de la fonction ;
; 'COMPIL' n'ecrit rien TIENS. ;
(IF (NOT (MEMQ (CAR L) '(DE DF)))
(*CMP L 1 NIL T)
(SETQ #namefnt (CADR L))
(SELECTQ (OR (CADR (GET #namefnt '!cmp)) (*TYPFNT L))
(0SUBR (*ADD1 ['ENTRY #namefnt 'SUBR 0]))
(1SUBR
(*ADD1 ['ENTRY #namefnt 'SUBR 1])
(SETQ #ca1 (CAAR (CDDR L)) #arg1 #ca1)
(OR
(CADDR (GET #namefnt '!cmp))
(*ADD '(JSP L :SBIND1)
['XWD [QUOTE #namefnt] [QUOTE #arg1]])))
(2SUBR
(SETQ #ca1 (CAADDR L) #arg1 #ca1)
(*ADD ['ENTRY #namefnt 'SUBR 2] '(JSP L :SBIND2)
['XWD [QUOTE #namefnt] [QUOTE (CADDR L)]]))
(3SUBR
(*ADD ['ENTRY #namefnt 'SUBR 3] '(JSP L :SBIND3)
['XWD [QUOTE #namefnt] [QUOTE (CADDR L)]]))
(NSUBR
(*ADD ['ENTRY #namefnt 'SUBR] '(JSP L :SBIND)
['XWD [QUOTE #namefnt] [QUOTE (CADDR L)]]))
(FSUBR
(*ADD ['ENTRY #namefnt 'FSUBR] '(JSP L :FSBIND)
['XWD [QUOTE #namefnt] [QUOTE (CADDR L)]]))
(NIL))
(NEXTL L)
(*CMP (CONS 'PROGN (CDDR L)) 1 NIL))
(*ADD1 '(POPJ P))
(IF ?sw1 (PRINT '#label '= #label))
(*RESOL #lap #label))
; 45 fnts principales : COMPILPR ;
(DE COMPILPR (L ?sw1 ;; S)
; compile L en appellant 'COMPIL' ;
; et passe le temps a raconter sa vie ... si ?sw1 = T ;
; ramene #lap ;
(IF ?sw1
(PROGN
(PAGE)
(PRINC (ASCII 59))
(PRIN1 (INCR NFNTS) (CADR L))
(PRINC '- 55)
(TERPRI 2)
(PRETTYP L)
(TERPRI)
(PRINT 'FUNCTION 'LENGTH '= (*LENS L))))
(SETQ S (COMPIL L))
(IF ?sw1
(PROGN
(PRINT '#lap 'LENGTH '= (*LENL S))
(PRINC (ASCII 59))
(TERPRI)))
(IF ?filap (PRINT '/( 'LAP '/'/( ))
(IF ?sw1 (PRLAP S) (LAPACK S))
(NCONC S (PRTBL))
(NCONC S (PRSSEC))
(IF ?filap (PRINT '/) '/)) (PRINT '(END)))
S)
; 46 fnts stds : COMPILES COMPILE COMPILERROR COMPILEREASE ;
(DE COMPILES (L ?sw1 ;; X #stk #esc #tbl #ssec)
; compile le S-expression L ;
; ?sw1 = T si le compilo cause ;
; #stk niveau de pile courant ;
; #esc LISTE DES ESCAPES ACTIFS ;
; RAMENE LA LISTE DU #lap ;
(SETQ #tbl (CONS) #ssec (CONS))
(SETQ CPTBL 0 CPTSSEC 0)
(OR ?nossec (*LKM L))
(SETQ #stk 0)
(COMPILPR L ?sw1))
(DF COMPILE (L ;; X)
; COMPILE , ASSEMBLE ET CHARGE UNE FONCTION STD ;
; APPEL: (COMPILE FONCTION ?sw1) ;
; ?sw1 pour COMPIL ;
(LAP
(COMPILES
(COND
((SETQ X (GET (CAR L) EXPR))
(MCONS 'DE (CAR L) (CDR X)))
((SETQ X (GET (CAR L) FEXPR))
(MCONS 'DF (CAR L) (CDR X)))
(T NIL))
(CADR L))
(CADDR L))
(REMPROP (CAR L) EXPR)
(REMPROP (CAR L) FEXPR)
'COMPILE)
(DE COMPILERROR L
; BUG IN COMPIL !!! ;
(TERPRI)
(PRINC '* 10 ) (PRIN1 'COMPILERROR) (PRINC '* 10) (TERPRI)
(MAPC L (LAMBDA (L) (PRINT L)))
(INPUT) (OUTPUT) (ERROR 'COMPILERROR) (RESET)))))
(DE COMPILEREASE (L)
; efface tous les indicateurs poses par le ;
; compilateur sur l'atome L ;
(REMPROP L '!cmp)
(REMPROP L '!commut)
(REMPROP L '!macmp))
; 47 fnts stds : COMPILEFILE ;
(DE COMPILEFILE (filout filin ?sw1 ;; S NFNTS)
; filout = FICHIER RESULTANT DE LA COMPILATION ;
; filin = FICHIER D'ENTREE A COMPILER ;
; ?sw1 = T si on veut une joulie presentation ;
(IF ?sw1
(IF (EQ (TYPEFN 'PRETTY) 'AUTOLOAD) (LIBRARY PRETTY))
(IF (EQ (TYPEFN 'LAPACK) 'AUTOLOAD) (LIBRARY LAPACK)))
; init no de page ;
(SETQ NFNTS 1)
(OUTPUT filout)
(STATUS 2 20)
;;
;*** premiere passe ;
;;
(PRCOMMENT (INCR NFNTS) (PRINC '* 30)
(PRIN1 (DATE) (TIME) '&pass1))
(TERPRI 2)
(IFN ?filap (PRINT '/( 'EVAL))
(PRINT '/( 'MAPC '/' '/()
(INPUT filin)
(ESCAPE &pass1
(DE EOF () (REMPROP 'EOF EXPR) (&pass1))
(WHILE T
(SETQ S (READ))
(COND
((ATOM S))
((MEMQ (CAR S) '(DE DF))
(COMPILEREASE (CADR S))
(PRIN1 (CADR S))
(TTAB 15)
(PRCOMMENT (PRIN1 (*TYPFNT S)))
(TERPRI))
((EQ (CAR S) 'DA)
(IF (NEQ (CAADR S) QUOTE) ()
(COMPILEREASE (CADR (CADR S)))
(PRCOMMENT (PRIN1 (CADR (CADR S)) 'ARRAY))
(TERPRI)
(PUT (CADR (CADR S))
(IF ?ckarray '(ARRAY 1SUBR 1SUBR)
'(ARRAY 1SUBR 1SUBR T))
'!cmp)))
((EQ (CAR S) 'DM)
(COMPILEREASE (CADR S))
(PRCOMMENT (PRIN1 (CADR S) 'MACRO))
(TERPRI)
(EVAL S)))))
(TERPRI)
(PRINT '/) '(LAMBDA (L) (PUT L NIL 'ENTRY)) '/))
(IFN ?filap (PRINT '/)))
(TERPRI 2)
;;
; ATTENTION : la fonction COMPILEFILE continue ..... ;
; 48 fnts stds : COMPILEFILE (suite) COMPILEF ;
;;
;;
;**** deuxieme passe. ;
;;
(PRCOMMENT (PRINC '* 30) (PRIN1 (DATE) (TIME) '&pass2))
(TERPRI 2)
(INPUT filin)
(ESCAPE &pass2
(DE EOF ()
(REMPROP 'EOF EXPR)
(STATUS 1 20)
(TERPRI)
(PRCOMMENT (PRINC '* 30)
(PRIN1 (DATE) (TIME) 'COMPILEND))
(TERPRI)
(INPUT)
(OUTPUT)
(&pass2 filout))
(WHILE T
(SETQ S (READ))
(IF (AND (LISTP S) (MEMQ (CAR S) '(DE DF)))
(COMPILES S ?sw1)
(TERPRI)
(PRCOMMENT (PRINC '- 66) (TERPRI)
(PRIN1 "NOT COMPILED."))
(TERPRI)
(IFN ?filap (PRINT '/( 'EVAL))
(PRETTYP S)
(IFN ?filap (PRINT '/))))))))
(DF COMPILEF (F)
; compile un fichier de maniere standard ;
; appel (COMPILEF filename ?sw1) ;
(COMPILEFILE ['DSK (CONS (CAR F)
(IF ?filap 'LAP (IF (CADR F) 'VLA 'VLO)))
(GETPPN)
\055]
(CAR F)
(CADR F))))))))
; 49 fnts stds : COMPILEND COMPILINDIC ;
(DE COMPILINDIC ()
; imprime tous les indics poses par le compilo ;
(MAPC
(SORTL (MAPCT (OBLIST)
(LAMBDA (L) (AND (GETL L '(!cmp !gen !commut !macmp)) L))))
(LAMBDA (L ;; X)
(PRIN1 L)
(AND (SETQ X (GET L '!cmp)) (TTAB 15) (PRINT '!cmp X))
(AND (SETQ X (GET l '!gen)) (TTAB 15) (PRINT '!gen))
(AND (SETQ X (GET L '!commut)) (TTAB 15) (PRINT '!commut X))
(AND (SETQ X (GET L '!macmp)) (TTAB 15) (PRINT '!macmp X)) )))))))
(DE COMPILEND ()
; detruit toutes les definitions du compilateur ;
(MAPC '(-lskip -lkst -larithi -laritha) (LAMBDA (L) (SET L NIL)))
(MAPC (OBLIST) (LAMBDA (L)
(REMPROP L '!cmp)
(REMPROP L '!commut)
(REMPROP L '!macmp)
(REMPROP L '!larg)))
(MAPC '(COMPILE COMPILEF MACMP PRCOMMENT TMACMP)
(LAMBDA (L) (REMPROP L 'FEXPR)))
(MAPC
'(MEXPAND *SSB *SSBP *SSB1 *TYPFNT *UNIQUEP *18BITP
*ISKIP *ADD *ADD1 *RSTL
*RESOL *SCR *RCR *OPT *LKT *LKM *LK0 *LK1 *KST *PKST *ISARG
*CMPRED *PA1 *LAMBDA *PROGN *TWO *GEN *CMP *LENS *LENL PRSSEC
PRTBL PRCOD PRLAP COMPIL COMPILPR COMPILES COMPILE COMPILEFILE
COMPILINDIC COMPILOPTIONS
COMPILEND) (LAMBDA (X) (REMPROP X 'EXPR)))
(AUTOLOAD COMPIL COMPILE COMPILES COMPILEFILE COMPILEF COMPILEND)
)))))
(POUR EVAL (MAPC (MAPCAR (MAKLIST "SYS:COMPIL.VLI loaded.
") 'CASCII) 'TYO))))